home *** CD-ROM | disk | FTP | other *** search
/ Windows Game Programming for Dummies (2nd Edition) / WinGamProgFD.iso / pc / DirectX SDK / DXSDK / samples / Multimedia / VBSamples / DirectDraw / Tutorials / Tut4 / DDtut4.frm (.txt) next >
Encoding:
Visual Basic Form  |  2001-10-08  |  7.0 KB  |  211 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    BorderStyle     =   0  'None
  4.    Caption         =   "DD Animation"
  5.    ClientHeight    =   5625
  6.    ClientLeft      =   2355
  7.    ClientTop       =   1620
  8.    ClientWidth     =   7065
  9.    Icon            =   "DDtut4.frx":0000
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   375
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   471
  14. Attribute VB_Name = "Form1"
  15. Attribute VB_GlobalNameSpace = False
  16. Attribute VB_Creatable = False
  17. Attribute VB_PredeclaredId = True
  18. Attribute VB_Exposed = False
  19. Option Explicit
  20. 'NOTE THIS SAMPLES SHOWS HOW TO BLIT TO AREAS OF THE SCREEN
  21. Dim binit As Boolean
  22. Dim dx As New DirectX7
  23. Dim dd As DirectDraw7
  24. Dim lakesurf As DirectDrawSurface7
  25. Dim spritesurf As DirectDrawSurface7
  26. Dim primary As DirectDrawSurface7
  27. Dim backbuffer As DirectDrawSurface7
  28. Dim ddsd1 As DDSURFACEDESC2
  29. Dim ddsd2 As DDSURFACEDESC2
  30. Dim ddsd3 As DDSURFACEDESC2
  31. Dim ddsd4 As DDSURFACEDESC2
  32. Dim spriteWidth As Integer
  33. Dim spriteHeight As Integer
  34. Dim cols As Integer
  35. Dim rows As Integer
  36. Dim row As Integer
  37. Dim col As Integer
  38. Dim currentFrame As Integer
  39. Dim brunning As Boolean
  40. Dim CurModeActiveStatus As Boolean
  41. Dim bRestore As Boolean
  42. Dim sMedia As String
  43. Sub Init()
  44.     On Local Error GoTo errOut
  45.     Dim file As String
  46.     Set dd = dx.DirectDrawCreate("")
  47.     Me.Show
  48.     'indicate that we dont need to change display depth
  49.     Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
  50.     Call dd.SetDisplayMode(640, 480, 16, 0, DDSDM_DEFAULT)
  51.     'get the screen surface and create a back buffer too
  52.     ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
  53.     ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
  54.     ddsd1.lBackBufferCount = 1
  55.     Set primary = dd.CreateSurface(ddsd1)
  56.     'Get the backbuffer
  57.     Dim caps As DDSCAPS2
  58.     caps.lCaps = DDSCAPS_BACKBUFFER
  59.     Set backbuffer = primary.GetAttachedSurface(caps)
  60.     backbuffer.GetSurfaceDesc ddsd4
  61.          
  62.     'Create DrawableSurface class form backbuffer
  63.     backbuffer.SetFontTransparency True
  64.     backbuffer.SetForeColor vbGreen
  65.          
  66.     ' init the surfaces
  67.     InitSurfaces
  68.                                                   
  69.     binit = True
  70.     brunning = True
  71.     Do While brunning
  72.         blt
  73.         DoEvents
  74.     Loop
  75. errOut:
  76.     EndIt
  77. End Sub
  78. Sub InitSurfaces()
  79.     Set lakesurf = Nothing
  80.     Set spritesurf = Nothing
  81.     sMedia = FindMediaDir("lake.bmp")
  82.     If sMedia = vbNullString Then sMedia = AddDirSep(CurDir)
  83.     'load the bitmap into a surface - lake
  84.     ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  85.     ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  86.     ddsd2.lWidth = ddsd4.lWidth
  87.     ddsd2.lHeight = ddsd4.lHeight
  88.     Set lakesurf = dd.CreateSurfaceFromFile(sMedia & "lake.bmp", ddsd2)
  89.                         
  90.     'load the bitmap into a surface
  91.     'this bitmap has many frames of animation
  92.     'each is 32 by 32 in layed out in cols x rows
  93.     ddsd3.lFlags = DDSD_CAPS
  94.     ddsd3.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  95.     Set spritesurf = dd.CreateSurfaceFromFile(sMedia & "animate.bmp", ddsd3)
  96.     spriteWidth = 32
  97.     spriteHeight = 32
  98.     cols = ddsd3.lWidth / spriteWidth
  99.     rows = ddsd3.lHeight / spriteHeight
  100.     'use black for transparent color key which is on
  101.     'the source bitmap -> use src keying
  102.     Dim key As DDCOLORKEY
  103.     key.low = 0
  104.     key.high = 0
  105.     spritesurf.SetColorKey DDCKEY_SRCBLT, key
  106. End Sub
  107. Sub blt()
  108.     On Local Error GoTo errOut
  109.     If binit = False Then Exit Sub
  110.     Dim ddrval As Long
  111.     Static i As Integer
  112.     Dim rBack As RECT
  113.     Dim rLake As RECT
  114.     Dim rSprite As RECT
  115.     Dim rSprite2 As RECT
  116.     Dim rPrim As RECT
  117.     Static a As Single
  118.     Static x As Single
  119.     Static y As Single
  120.     Static t As Single
  121.     Static t2 As Single
  122.     Static tLast As Single
  123.     Static fps As Single
  124.     ' this will keep us from trying to blt in case we lose the surfaces (alt-tab)
  125.     bRestore = False
  126.     Do Until ExModeActive
  127.         DoEvents
  128.         bRestore = True
  129.     Loop
  130.     ' if we lost and got back the surfaces, then restore them
  131.     DoEvents
  132.     If bRestore Then
  133.         bRestore = False
  134.         dd.RestoreAllSurfaces
  135.         InitSurfaces ' must init the surfaces again if they we're lost
  136.     End If
  137.     'get the area of the screen where our window is
  138.     rBack.Bottom = ddsd4.lHeight
  139.     rBack.Right = ddsd4.lWidth
  140.     'get the area of the bitmap we want ot blt
  141.     rLake.Bottom = ddsd2.lHeight
  142.     rLake.Right = ddsd2.lWidth
  143.     'blt to the backbuffer from our  surface to
  144.     'the screen surface such that our bitmap
  145.     'appears over the window
  146.     ddrval = backbuffer.BltFast(0, 0, lakesurf, rLake, DDBLTFAST_WAIT)
  147.     'Calculate the frame rate
  148.     If i = 30 Then
  149.         If tLast <> 0 Then fps = 30 / (Timer - tLast)
  150.         tLast = Timer
  151.         i = 0
  152.     End If
  153.     i = i + 1
  154.     Call backbuffer.DrawText(10, 10, "640x480x16 Frames per Second " + Format$(fps, "#.0"), False)
  155.     Call backbuffer.DrawText(10, 30, "Click Screen to Exit", False)
  156.     'calculate the angle from the center
  157.     'at witch to place the sprite
  158.     'calcultate wich frame# we are on in the sprite bitmap
  159.     t2 = Timer
  160.     If t <> 0 Then
  161.         a = a + (t2 - t) * 40
  162.         If a > 360 Then a = a - 360
  163.         currentFrame = currentFrame + (t2 - t) * 40
  164.         If currentFrame > rows * cols - 1 Then currentFrame = 0
  165.     End If
  166.     t = t2
  167.     'calculat the x and y position of the sprite
  168.     x = Cos((a / 360) * 2 * 3.141) * 100
  169.     y = Sin((a / 360) * 2 * 3.141) * 100
  170.     rSprite2.Top = y + Me.ScaleHeight / 2
  171.     rSprite2.Left = x + Me.ScaleWidth / 2
  172.     rSprite2.Right = rSprite2.Left + spriteWidth
  173.     rSprite2.Bottom = rSprite2.Top + spriteHeight
  174.     'from the current frame select the bitmap we want
  175.     col = currentFrame Mod cols
  176.     row = Int(currentFrame / cols)
  177.     rSprite.Left = col * spriteWidth
  178.     rSprite.Top = row * spriteHeight
  179.     rSprite.Right = rSprite.Left + spriteWidth
  180.     rSprite.Bottom = rSprite.Top + spriteHeight
  181.       
  182.     'blt to the backbuffer our animated sprite
  183.     ddrval = backbuffer.BltFast(rSprite2.Left, rSprite2.Top, spritesurf, rSprite, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT)
  184.     'flip the back buffer to the screen
  185.     primary.Flip Nothing, DDFLIP_WAIT
  186. errOut:
  187. End Sub
  188. Sub EndIt()
  189.     Call dd.RestoreDisplayMode
  190.     Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
  191.     End
  192. End Sub
  193. Private Sub Form_Click()
  194.     EndIt
  195. End Sub
  196. Private Sub Form_Load()
  197.     Init
  198. End Sub
  199. Private Sub Form_Paint()
  200.     blt
  201. End Sub
  202. Function ExModeActive() As Boolean
  203.     Dim TestCoopRes As Long
  204.     TestCoopRes = dd.TestCooperativeLevel
  205.     If (TestCoopRes = DD_OK) Then
  206.         ExModeActive = True
  207.     Else
  208.         ExModeActive = False
  209.     End If
  210. End Function
  211.